home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / Tk.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  8.7 KB  |  472 lines
  1. package Tk;
  2. require 5.004;
  3. use     AutoLoader qw(AUTOLOAD);
  4. use     DynaLoader;
  5. require Exporter;
  6. @Tk::ISA = qw(Exporter DynaLoader);
  7.  
  8.  
  9. @EXPORT    = qw(Exists Ev after exit MainLoop DoOneEvent tkinit);
  10. @EXPORT_OK = qw(NoOp *widget *event lsearch catch 
  11.                 DONT_WAIT WINDOW_EVENTS  FILE_EVENTS TIMER_EVENTS 
  12.                 IDLE_EVENTS ALL_EVENTS 
  13.                 NORMAL_BG ACTIVE_BG SELECT_BG 
  14.                 SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE);
  15. %EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS  FILE_EVENTS 
  16.                                   TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], 
  17.                 variables  => [qw(*widget *event)],
  18.                 colors     => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG 
  19.                                   TROUGH INDICATOR DISABLED BLACK WHITE)],
  20.                );
  21.  
  22. use strict;
  23. use Symbol ();
  24.  
  25. use Carp;
  26.  
  27. $Tk::version     = "4.2";
  28. $Tk::patchLevel  = "4.2";
  29. $Tk::VERSION     = '402.002';
  30. $Tk::strictMotif = 0;
  31.                                    
  32. {($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;}
  33. $Tk::library = Tk->findINC('.') unless (-d $Tk::library);
  34.  
  35. $Tk::widget  = undef;
  36. $Tk::event   = undef;
  37.  
  38. use vars qw($TkVtab $TkintVtab $LangVtab $TkglueVtab $XlibVtab $TkoptionVtab);  
  39. use vars qw($TixVtab $TixintVtab $TiximgxpmVtab);
  40.  
  41. bootstrap Tk $Tk::VERSION;
  42.  
  43. {
  44.  no strict 'refs';
  45.  *{'exit'} = \&Exit;
  46. }
  47. my $boot_time = timeofday();
  48.  
  49. Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) if (&NeedPreload && -d '/usr/openwin/lib');
  50.  
  51. use Tk::Submethods ('option'    =>  [qw(add get clear readfile)],
  52.                     'clipboard' =>  [qw(clear append)]
  53.                    );
  54.  
  55. sub BackTrace
  56. {
  57.  my $w = shift;
  58.  return unless (@_ || $@);
  59.  my $mess = (@_) ? shift : "$@";
  60.  my $i = 0;  
  61.  my ($pack,$file,$line,$sub) = caller($i++);
  62.  while (1)   
  63.   {          
  64.    my $loc = "at $file line $line";
  65.    ($pack,$file,$line,$sub) = caller($i++);
  66.    last if (!defined($sub) || $sub eq '(eval)');
  67.    $w->AddErrorInfo("$sub $loc");
  68.   }          
  69.  die "$mess\n";
  70. }
  71.  
  72. sub NoOp  { }
  73.  
  74. sub Ev
  75. {
  76.  my @args = @_;
  77.  my $obj;
  78.  if (@args == 1)
  79.   {
  80.    my $arg = pop(@args);
  81.    $obj = (ref $arg) ? $arg : \$arg;
  82.   }
  83.  else 
  84.   {
  85.    $obj = \@args;
  86.   }
  87.  return bless $obj,"Tk::Ev";
  88. }
  89.  
  90. sub InitClass
  91. {
  92.  my ($package,$parent) = @_;
  93.  croak "Unexpected type of parent $parent" unless(ref $parent);
  94.  croak "$parent is not a widget" unless($parent->IsWidget);
  95.  my $mw = $parent->MainWindow;
  96.  unless (exists $mw->{'_ClassInit_'}{$package})
  97.   {
  98.    $package->Install($mw);
  99.    $mw->{'_ClassInit_'}{$package} = $package->ClassInit($mw);
  100.   }
  101. }
  102.  
  103. require Tk::Widget;
  104. require Tk::Image;
  105. require Tk::MainWindow;
  106.  
  107. sub Exists
  108. {my $w = shift;
  109.  return defined($w) && ref($w) && $w->IsWidget && $w->exists;
  110. }
  111.  
  112. sub Time_So_Far
  113. {
  114.  return timeofday() - $boot_time;
  115. } 
  116.  
  117.  
  118. sub SelectionOwn
  119. {my $widget = shift;
  120.  selection('own',(@_,$widget));
  121. }
  122.  
  123. sub SelectionOwner
  124. {
  125.  selection('own',"-displayof",@_);
  126. }
  127.  
  128. sub SelectionClear
  129. {
  130.  selection('clear',"-displayof",@_);
  131. }
  132.  
  133. sub SelectionExists
  134. {
  135.  selection('exists',"-displayof",@_);
  136. }
  137.  
  138. sub SelectionHandle
  139. {my $widget = shift;
  140.  my $command = pop;
  141.  selection('handle',@_,$widget,$command);
  142. }
  143.  
  144. sub __DIE__
  145. {
  146.  my $mess = shift;
  147.  my $w = $Tk::widget;
  148.  if (defined $w)
  149.   {
  150.    my $i = 0;  
  151.    my ($pack,$file,$line,$sub) = caller($i++);
  152.    while (1)   
  153.     {          
  154.      my $loc = "at $file line $line";
  155.      ($pack,$file,$line,$sub) = caller($i++);
  156.      last if (!defined($sub) || $sub eq '(eval)');
  157.      $w->AddErrorInfo("$sub $loc");
  158.     }          
  159.   }
  160. }
  161.  
  162. sub fileevent
  163. {
  164.  require Tk::IO;
  165.  my ($obj,$file,$mode,$cb) = @_;
  166.  croak "Unknown mode '$mode'" unless $mode =~ /^(readable|writeable)$/;
  167.  unless (ref $file)
  168.   {
  169.    require IO::Handle;
  170.    no strict 'refs';
  171.    $file = Symbol::qualify($file,(caller)[0]);
  172.    $file = bless \*{$file},'IO::Handle';
  173.   }
  174.  if ($cb)
  175.   {
  176.    $cb = Tk::Callback->new($cb);
  177.    if ($mode eq 'readable')
  178.     {
  179.      Tk::IO::CreateReadHandler($file,$cb);
  180.     }
  181.    else
  182.     {
  183.      Tk::IO::CreateWriteHandler($file,$cb);
  184.     }
  185.   }
  186.  else
  187.   {
  188.    if ($mode eq 'readable')
  189.     {
  190.      Tk::IO::DeleteReadHandler($file);
  191.     }
  192.    else
  193.     {
  194.      Tk::IO::DeleteWriteHandler($file);
  195.     }
  196.   }
  197. }
  198.  
  199. sub SplitString
  200. {
  201.  local $_ = shift;
  202.  carp "SplitString '$_'";
  203.  my (@arr, $tmp);
  204.  while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
  205.    if (defined $1) { push @arr, $1 }
  206.    else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
  207.  }
  208.  return @arr;
  209. }
  210.  
  211.  
  212. 1;
  213.  
  214. __END__
  215. sub exit { CORE::exit(@_);}
  216.  
  217. sub Exists
  218. {my $w = shift;
  219.  return defined($w) && ref($w) && $w->IsWidget && $w->exists;
  220. }
  221.  
  222. sub Error
  223. {my $w = shift;
  224.  my $error = shift;
  225.  if (Exists($w))
  226.   {
  227.    my $grab = $w->grab('current');  
  228.    $grab->Unbusy if (defined $grab);
  229.   }
  230.  chomp($error);
  231.  warn "Tk::Error: $error\n " . join("\n ",@_);
  232. }
  233.  
  234. sub tkinit
  235. {
  236.  return MainWindow->new(@_);
  237. }
  238.  
  239. sub CancelRepeat
  240. {
  241.  my $w = shift->MainWindow;
  242.  my $id = delete $w->{_afterId_};
  243.  $w->after('cancel',$id) if (defined $id);
  244. }
  245.  
  246. sub RepeatId
  247. {
  248.  my ($w,$id) = @_;
  249.  $w = $w->MainWindow;
  250.  $w->CancelRepeat;
  251.  $w->{_afterId_} = $id;
  252. }
  253.  
  254.  
  255.  
  256.  
  257. sub FocusChildren { shift->children }
  258.  
  259. sub focusNext
  260. {
  261.  my $w = shift;
  262.  my $cur = $w;
  263.  while (1)
  264.   {
  265.    my $parent = $cur;
  266.    my @children = $cur->FocusChildren();
  267.    my $i = -1;
  268.    while (1)
  269.     {
  270.      $i += 1;
  271.      if ($i < @children)
  272.       {
  273.        $cur = $children[$i];
  274.        next if ($cur->toplevel == $cur);
  275.        last
  276.       }
  277.      $cur = $parent;
  278.      last if ($cur->toplevel() == $cur);
  279.      $parent = $parent->parent();
  280.      @children = $parent->FocusChildren();
  281.      $i = lsearch(\@children,$cur);
  282.     }
  283.    if ($cur == $w || $cur->FocusOK)
  284.     {
  285.      $cur->Tk::focus;
  286.      return;
  287.     }
  288.   }
  289. }
  290. sub focusPrev
  291. {
  292.  my $w = shift;
  293.  my $cur = $w;
  294.  my @children;
  295.  my $i;
  296.  my $parent;
  297.  while (1)
  298.   {
  299.    if ($cur->toplevel() == $cur)
  300.     {
  301.      $parent = $cur;
  302.      @children = $cur->FocusChildren();
  303.      $i = @children;
  304.     }
  305.    else
  306.     {
  307.      $parent = $cur->parent();
  308.      @children = $parent->FocusChildren();
  309.      $i = lsearch(\@children,$cur);
  310.     }
  311.    while ($i > 0)
  312.     {
  313.      $i--;
  314.      $cur = $children[$i];
  315.      next if ($cur->toplevel() == $cur);
  316.      $parent = $cur;
  317.      @children = $parent->FocusChildren();
  318.      $i = @children;
  319.     }
  320.    $cur = $parent;
  321.    if ($cur == $w || $cur->FocusOK)
  322.     {
  323.      $cur->Tk::focus;
  324.      return;
  325.     }
  326.   }
  327.  
  328. }
  329.  
  330. sub FocusOK
  331. {
  332.  my $w = shift;
  333.  my $value;
  334.  catch { $value = $w->cget('-takefocus') };
  335.  if (!$@ && defined($value))
  336.   {
  337.    return 0 if ($value eq '0');
  338.    return 1 if ($value eq '1');
  339.    $value = $w->$value();
  340.    return $value if (defined $value);
  341.   }
  342.  if (!$w->viewable)
  343.   {
  344.    return 0;
  345.   }
  346.  catch { $value = $w->cget('-state') } ;
  347.  if (!$@ && defined($value) && $value eq "disabled")
  348.   {
  349.    return 0;
  350.   }
  351.  $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w)));
  352.  return $value;
  353. }
  354.  
  355.  
  356.  
  357. sub EnterFocus
  358. {
  359.  my $w  = shift;
  360.  my $Ev = $w->XEvent;
  361.  my $d  = $Ev->d;
  362.  $w->Tk::focus() if ($d eq "NotifyAncestor" ||  $d eq "NotifyNonlinear" ||  $d eq "NotifyInferior");
  363. }
  364.  
  365. sub focusFollowsMouse
  366. {
  367.  my $widget = shift;
  368.  $widget->bind('all',"EnterFocus");
  369. }
  370.  
  371. sub TraverseToMenu
  372. {
  373.  my $w = shift;
  374.  my $char = shift;
  375.  return unless(defined $char && $char ne "");
  376.  $w = $w->toplevel->FindMenu($char);
  377.  $w->PostFirst() if (defined $w);
  378. }
  379. sub FirstMenu
  380. {
  381.  my $w = shift;
  382.  $w = $w->toplevel->FindMenu("");
  383.  $w->PostFirst() if (defined $w);
  384. }
  385.  
  386.  
  387. sub Selection
  388. {my $widget = shift;
  389.  my $cmd    = shift;
  390.  croak "Use SelectionOwn/SelectionOwner" if ($cmd eq 'own');
  391.  croak "Use Selection\u$cmd()";
  392. }
  393.  
  394. sub Clipboard
  395. {my $w = shift;
  396.  my $cmd    = shift;
  397.  croak "Use clipboard\u$cmd()";
  398. }
  399.  
  400. sub Receive
  401. {
  402.  my $w = shift;
  403.  warn "Receive(" . join(',',@_) .")";
  404.  die "Tk rejects send(" . join(',',@_) .")\n";
  405. }
  406.  
  407. sub break
  408. {
  409.  die "_TK_BREAK_\n";
  410. }
  411.  
  412. sub idletasks
  413. {
  414.  shift->update('idletasks');
  415. }
  416.  
  417. sub updateWidgets
  418. {
  419.  my ($w) = @_;
  420.  while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
  421.   {
  422.   }
  423.  $w;
  424. }
  425.  
  426. sub ImageNames
  427. {
  428.  image('names');
  429. }
  430.  
  431. sub ImageTypes
  432. {
  433.  image('types');
  434. }
  435.  
  436. sub interps
  437. {
  438.  my $w = shift;
  439.  return $w->winfo('interps','-displayof');
  440. }
  441.  
  442. sub findINC
  443. {
  444.  my $file = join('/',@_);
  445.  my $dir;
  446.  $file  =~ s,::,/,g;
  447.  foreach $dir (@INC)
  448.   {
  449.    my $path;
  450.    return $path if (-e ($path = "$dir/$file"));
  451.   }
  452.  return undef;
  453. }
  454.  
  455. sub lsearch
  456. {my $ar = shift;
  457.  my $x  = shift;
  458.  my $i;
  459.  for ($i = 0; $i < scalar @$ar; $i++)
  460.   {
  461.    return $i if ($$ar[$i] eq $x);
  462.   }
  463.  return -1;
  464. }
  465.  
  466. sub catch (&)
  467. {
  468.  my $sub = shift;
  469.  eval {local $SIG{'__DIE__'}; &$sub };
  470. }
  471.  
  472.